;;; mozremote-object.el --- 

;; Copyright 2006 Lukas Loehrer
;;
;; Author: loehrerl [at] gmx [dot] net
;; Version: $Id: mozremote-object.el,v 0.0 2006/08/29 19:25:32 luke Exp $
;; Keywords: 
;; X-URL: not distributed yet

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:
;;;
;;;This file implements the remote object protocol provided by the
;;;"Remoting" service in mozremote.
;;;
;;;The intersting functions are:
;;;mozremote-object-call-method
;;;mozremote-object-call-method-sync

;;; Code:
(provide 'mozremote-object)
(eval-when-compile
  (require 'cl))

(require 'mozremote)
(require 'json)

;;{{{Object descriptor handling

(defvar mozremote-object-obtable
  (make-hash-table ':weakness 'value)
  "Hash table mapping numeric object ids to object descriptors.
Values are weak, so they disappear when descriptors are not referenced any more elsewhere.")

(defvar mozremote-object-list nil
  "List of numeric object IDs. 
This includes both IDs of live objects
and garbage objects that have not yet been declared garbage to Firefox.
The difference of this list and mozremote-object-obtable are the garbage objects.")

(defvar mozremote-object-list-length 0
  "Length of mozremote-object-list.

this is simply here to make the detection of cases where no garbage collection is needed easy.")

(add-hook 'mozremote-connect-hook 'mozremote-object-reset-local-state)

(defun mozremote-object-reset-local-state ()
  (maphash 'mozremote-object-invalidate-descriptor mozremote-object-obtable)
  (clrhash mozremote-object-obtable)
  (setq mozremote-object-list nil
		mozremote-object-list-length 0))

(defun mozremote-object-invalidate-descriptor (id desc)
  "Mark an object descriptor as invalid."
  (unless (mozremote-object-descriptor-p desc)
	(error "Invalid argument type."))
  (put desc 'mozremote-object-desc-invalid t))

(defsubst mozremote-object-descriptor-valid-p (desc)
  "Return t if desc is an object descriptor and not invalidated."
  (and (mozremote-object-descriptor-p desc) (not (get desc 'mozremote-object-desc-invalid))))
	
(defsubst mozremote-object-descriptor-get-id (desc)
  "Extract object ID from object descriptor."
  (get desc 'mozremote-object-id))

(defsubst mozremote-object-descriptor-p (desc)
  "Return t if desc is a mozremote object descriptor."
  (and (symbolp desc) (mozremote-object-descriptor-get-id desc)))

(defsubst mozremote-object-get-descriptor (id)
  "Return object descriptor for js object with ID, nil if if no such object hash been encountered."
  (gethash id mozremote-object-obtable))

(defun mozremote-object-make-descriptor (id)
  "Creates and returns a object descriptor with for id."
  (let ((desc (make-symbol (format "mozremote-object-ref-%d" id))))
	(put desc 'mozremote-object-id id)
	(puthash id desc mozremote-object-obtable)
	(push id mozremote-object-list)
	(incf mozremote-object-list-length)
	desc))
		
(defsubst mozremote-object-get-or-make-descriptor (id)
  "Returns the object descriptor for object with id.
Creates new descriptor if no descriptor for this object exists."
  (or (mozremote-object-get-descriptor id) (mozremote-object-make-descriptor id)))

;;}}}
;;{{{Object descriptor serialization

(defconst mozremote-object-magic-marker
  '~_MozremoteObjectType_~
  "Hopefully unique marker for object references in json.")



(defadvice json-encode (before mozremote-object pre act)
  "Serialization of object references."
  (let ((desc (ad-get-arg 0)))
	(when (mozremote-object-descriptor-p desc)
	  (unless (mozremote-object-descriptor-valid-p desc)
		(error "Tried to serialize an invalidated object descriptor."))
	  (let ((new-object 
			 (list
			  (cons mozremote-object-magic-marker "object-ref")
			  (cons 'id (mozremote-object-descriptor-get-id desc)))))
		(ad-set-arg 0 new-object)))))

(defadvice json-read-object (after mozremote-object pre act)
  "Handles deserialization of javascript object descriptors."
  (let ((type (mozremote-dictionary-get mozremote-object-magic-marker ad-return-value)))
	(when (equal type "object-ref")
	  (let ((id
			 (mozremote-dictionary-get 'id ad-return-value)))
		(if (numberp id)
			(setq ad-return-value
				  (mozremote-object-get-or-make-descriptor id)))))))

(defun mozremote-object-unserialize-references (object)
  (cond
   ((vectorp object)
	(loop for elem across  object for i from 0 do
		  (mozremote-array-set i (mozremote-object-unserialize-references elem) object))
	object)
   ((and object (listp object))
	(let ((type (mozremote-dictionary-get mozremote-object-magic-marker object))
		  (id (mozremote-dictionary-get 'id object)))
	  (if (and  (equal type "object-ref") (numberp id))
		  (mozremote-object-get-or-make-descriptor id)
		(progn
		  (loop for cell in object do
				(setcdr cell  (mozremote-object-unserialize-references (cdr cell))))
		  object))))
   (t object)))
					  
	

(defadvice mozremote-read-lisp-data (after mozremote-object pre act)
  (mozremote-object-unserialize-references ad-return-value))


;;}}}
;;{{{Garbage collection

(defvar mozremote-object-garbage-collecting nil
  "t if garbage collection is in progress.")

(defun mozremote-object-partition-list (list)
  "Partition LIST in such a way that IDs of live objects come first. Return tail containing only dead IDs."
  (let ((cur list)
		(sep list)
		tmp)
	(while cur
	  (when (gethash (car cur) mozremote-object-obtable)
		(setq tmp (car cur))
		(setcar cur (car sep))
		(setcar sep tmp)
		(setq sep (cdr sep)))
	  (setq cur (cdr cur)))
	sep))

(defun mozremote-object-garbage-collect ()
  "Sends list of   garbage objects to firefox.

This function is optimized to minimize additional memory allocation.
Also, the list of object IDs is only traversed once."
  (interactive)
  (when (and (not mozremote-object-garbage-collecting) (mozremote-connected-p))
	(let* ((mozremote-object-garbage-collecting t)
		   (live-count (hash-table-count mozremote-object-obtable))
		   (dead-count (- mozremote-object-list-length live-count)))
	  (when (> dead-count 0)
		(let* ((dead (mozremote-object-partition-list mozremote-object-list))
			   (result (mozremote-call-sync "Remoting" "collectGarbage" dead mozremote-received-message-count)))
		  (when result
			; Discard IDs of dead objects from list
			(setcar dead (car mozremote-object-list))
			(setcdr dead nil)
			(setq mozremote-object-list (cdr mozremote-object-list)
				  mozremote-object-list-length live-count))
		  (mozremote-log-event (format "Garbage collection for %d objects %s." dead-count (if result  "succeeded" "failed")))
		  result)))))


(defun mozremote-object-garbage-collect-hook ()
  "Schedules a mozremote-object garbage collection for as soon as possible."
  (run-at-time 0 nil 'mozremote-object-garbage-collect))

(when (>= emacs-major-version 22)
  (add-hook 'post-gc-hook 'mozremote-object-garbage-collect-hook))

;;}}}

;;{{{Public functions

(defun mozremote-object-new (type &rest args)
  "Returns instance of newliy created remote object.

this method is not used at the moment."
  (mozremote-call-sync "Remoting" "createInstance" "TestClass"))
   
(defun mozremote-object-call-method (handler object method &rest args)
  "remotely call METHOD on OBJECT with arguments ARGS. The result is passed to HANDLER asynchronously.

This method does not block but returns immediately after call message has been sent."
  (if (mozremote-object-descriptor-p object)
	  (mozremote-call handler "Remoting" "callMethod" object method args)
	(error "Not an object descriptor.")))

(defun mozremote-object-call-method-sync (object method &rest args)
  "Remotely calls method on object with arguments args and waits for the result to return."
  (if (mozremote-object-descriptor-p object)
	  (mozremote-call-sync "Remoting" "callMethod" object method args)
	(error "Not an object descriptor.")))


(defmacro mozremote-object-with-result  (result spec buffer &rest body)
    "Call remote method and execute BODY with the result bound to RESULT.

SPEC is  of the form (object method &rest args).
Buffer is the current buffer  while executing BODY."
  (let ((cont (gensym "mozremote"))
		(buf (gensym "mozremote")))
	(destructuring-bind (object method &rest args) spec 
	  `(let ((,cont
			  (lexical-let ((,buf ,buffer))
				(lambda (,result)
				  (with-current-buffer ,buf
					,@body)))))
		 (mozremote-object-call-method ,cont ,object ,method ,@args)))))


;;}}}

;;{{{  emacs local variables

;;; local variables:
;;; folded-file: t
;;; byte-compile-dynamic: t
;;; end:

;;}}}

;;; mozremote-object.el ends here
